(library (grid-gen OpenDX)

(export OpenDX:save)

(import (guile)
        (rnrs)
        (grid-gen main)
        (grid-gen code)
        (grid-gen vars)
        (except (srfi srfi-1) map)
)

(define wq (lambda (s) (string-append "\"" s "\"")))

(define oidn 1)

(define objids (make-hash-table))

(define wr-conn (lambda (grds bin-ofs)
  (let* ((oid (let ((o oidn))
                (hash-set! objids "connections" o)
                (set! oidn (+ oidn 1))
                o
              )
         )
         (dms (map (lambda (gr) (gr 'dims-full)) grds))
         (ndms (map length dms))
         (chk (if (not (= (apply min ndms) (apply max ndms)))
                  (int-err "Cannot save grids with different ranks!")
              )
         )
         (ndims (car ndms))
         (get-gr-keys (lambda (gr)
                        (filter (lamln 1)
                                (apply
                                  append
                                  (map (lambda (d)
                                        `(((,d 0) ,(gr 'get-bnd-key `(,d 0)))
                                          ((,d 1) ,(gr 'get-bnd-key `(,d 1)))
                                         )
                                       )
                                       (iota1 ndims)
                                  )
                                )
                        )
                      )
         )
         (gnm (let ((h (make-hash-table)))
                   (for-each (lambda (ig) (hash-set! h (cadr ig) (car ig)))
                             (zip (iota1 (length grds)) grds)
                   )
                   h
              )
         )
         (dms1 (map (lambda (d) (map dec d)) dms))
         (ncn1 (apply + (map (lambda (d) (apply * d)) dms1)))
         (gpr1 (let ((h (make-hash-table)))
                 (map (lambda (gr)
                        (let* ((nd (gr 'ndims))
                               (fk1 (get-gr-keys gr))
                               (fk2 (map (lambda (ijk)
                                           (let ((g1ij (hash-ref h 
                                                                 (cadr ijk)
                                                                 #f
                                                       )
                                                 )
                                                )
                                             (if g1ij
                                                `(,g1ij (,gr ,(car ijk)))
                                                 (begin
                                                   (hash-set! h
                                                              (cadr ijk)
                                                             `(,gr ,(car ijk))
                                                   )
                                                   #f
                                                 )
                                             )
                                           )
                                         )
                                         fk1
                                    )
                               )
                              )
                          (filter (lamn 0) fk2)
                        )
                      )
                      grds
                 )
               )
         ) 
         (gprs (apply append gpr1)) ;; -> (((gr1 ij1) (gr2 ij2)) ...)
         (walls (map (lambda (pr)
                       (let* ((gp1 (car pr))
                              (gp2 (cadr pr))
                              (g1 (car gp1))
                              (g2 (car gp2))
                              (dm1 (g1 'dims-full))
                              (dm2 (g2 'dims-full))
                              (d1 (car (cadr gp1)))
                              (s1 (cadr (cadr gp1)))
                              (d2 (car (cadr gp2)))
                              (s2 (cadr (cadr gp2)))
                              (gn1 (hash-ref gnm g1 #f))
                              (gn2 (hash-ref gnm g2 #f))
                             )
                        `((,gn1 ,d1 ,s1 ,dm1) (,gn2 ,d2 ,s2 ,dm1))
                       )
                     )
                     gprs
                )
         )
         (walsiz (map (lambda (wl)
                        (let* ((w1 (car wl))
                               (dm1 (cadddr w1))
                               (d1 (cadr w1))
                              )
                          (apply * (map dec (list-cut dm1 d1)))
                        )
                      )
                      walls
                 )
         )
         (allwalsiz (apply + walsiz))
         (fdatsiz (+ ncn1 allwalsiz))
         (simp-grid (and (= (length grds) 1)
                         (null? (get-gr-keys (car grds)))
                    )
         )
         (datsiz (if simp-grid 0 fdatsiz))
         (rcod (beg
                 (set! oidn (+ oidn 1))
                 (main-p
                   (if simp-grid 
                       (if (or (not bin-ofs) (not (boolean? bin-ofs)))
                           (apply fprint
                                  (append `(,("object "
                                              oid
                                              " class gridconnections counts"
                                             )
                                           )
                                           ((car grds) 'dims-full)
                                  )
                           )
                           nop
                       )
                       (beg
                         (if (or (not bin-ofs) (not (boolean? bin-ofs)))
                             (fprint "object" oid
                                     "class array type integer rank 1 shape"
                                     (expt 2 ndims)
                                     "items" fdatsiz
                                     (if (not (boolean? bin-ofs))
                                         "lsb ieee data"
                                         "data"
                                     )
                                     (if (not (boolean? bin-ofs))
                                         (* bin-ofs 4)
                                         " follows"
                                     )
                             )
                             nop
                         )
                         (apply beg
                           (map (lambda (id)
                                  (let* ((ng (car id))
                                         (dms2 (cadr id))
                                         (ndm (length dms2))
                                         (nc (lambda (ol)
                                               (iptr
                                                 (reverse
                                                   (map (lambda (d)
                                                         `(+ ,(cur-ptr d)
                                                             ,(list-ref ol d)
                                                          )
                                                        )
                                                        (iota1 ndm)
                                                   )
                                                 )
                                                 (reverse (list-ref dms ng))
                                               )
                                             )
                                         )
                                         (ofs (apply + (map (lambda (d)
                                                              (apply * d)
                                                            )
                                                            (list-head dms ng)
                                                       )
                                                )
                                         )
                                         (wrcod (lambda (prnt)
                                           (do-loop dms2
                                             (apply
                                               prnt
                                               (map (lambda (b)
                                                     `(+ ,ofs
                                                         ,(nc (map (lambda (d)
                                                                     (if 
                                                                       (logbit?
                                                                         d
                                                                         b
                                                                       )
                                                                       1
                                                                       0
                                                                     )
                                                                   )
                                                                   (iota1 ndm)
                                                              )
                                                            )
                                                      )
                                                    )
                                                    (iota1 (expt 2 ndm))
                                               )
                                             )
                                           )
                                         ))
                                        )
                                    (if (not bin-ofs)
                                        (wrcod fprint)
                                        (if (boolean? bin-ofs)
                                            (wrcod fwrite)
                                            nop
                                        )
                                    )
                                  )
                                )
                                (zip (iota1 (length dms1)) dms1)
                           )
                         )
                         (apply beg
                           (map (lambda (w)
                                  (let* ((w1 (car w))
                                         (w2 (cadr w))
                                         (gn1 (car w1))
                                         (gn2 (car w2))
                                         (g1 (list-ref grds gn1))
                                         (d1 (cadr w1))
                                         (s1 (caddr w1))
                                         (mp1 (list-ref (g1 'getbnd d1 s1) 4))
                                         (mpp (lambda (l)
                                           (map (lambda (d)
                                                  (let ((a (assoc d mp1)))
                                                    (list-ref
                                                      l 
                                                      (if a (cadr a) d)
                                                    )
                                                  )
                                                )
                                                (iota1 (length l))
                                           )
                                         ))
                                        (d2 (cadr w2))
                                        (s2 (caddr w2))
                                        (dm1 (cadddr w1))
                                        (dm2 (cadddr w2))
                                        (dmc1 (map dec (list-cut dm1 d1)))
                                        (ptr (lambda (b dm ss dd)
                                          (map (lambda (d)
                                                 (if (= d dd)
                                                     (inc (* ss
                                                             (dec 
                                                               (list-ref dm dd)
                                                             )
                                                          )
                                                     )
                                                     (let ((d1 (if (< d dd)
                                                                   d
                                                                   (dec d)
                                                               )
                                                           )
                                                          )
                                                      `(+ ,(if (logbit? d b)
                                                               1
                                                               0
                                                           )
                                                          ,(cur-ptr d1)
                                                       )
                                                     )
                                                 )
                                               )
                                               (iota1 (length dm))
                                          )
                                        ))
                                        (ofs1 (apply + (map (lambda (d)
                                                              (apply * d)
                                                            )
                                                            (list-head dms gn1)
                                                        )
                                              )
                                        )
                                        (ofs2 (apply + (map (lambda (d)
                                                              (apply * d)
                                                            )
                                                            (list-head dms gn2)
                                                       )
                                              )
                                        )
                                        (wrcod (lambda (prnt)
                                          (do-loop dmc1
                                            (apply
                                              prnt
                                              (map (lambda (b)
                                                     (if (logbit? d1 b)
                                                        `(+ ,ofs2
                                                            ,(iptr
                                                               (reverse
                                                                 (ptr b 
                                                                      dm2
                                                                      s2
                                                                      d2
                                                                 )
                                                               )
                                                               (reverse
                                                                 (list-ref
                                                                   dms
                                                                   gn2
                                                                 )
                                                               )
                                                             )
                                                         )
                                                        `(+ ,ofs1
                                                            ,(iptr
                                                               (reverse
                                                                 (mpp (ptr b
                                                                           dm1
                                                                           s1
                                                                           d1
                                                                      )
                                                                 )
                                                               )
                                                               (reverse
                                                                 (mpp (list-ref
                                                                        dms
                                                                        gn1
                                                                      )
                                                                 )
                                                               )
                                                             )
                                                         )
                                                     )
                                                   )
                                                   (iota1 (expt 2
                                                                (length dm1)
                                                          )
                                                   )
                                              )
                                            )
                                          )
                                        ))
                                       )
                                    (if (not bin-ofs)
                                        (wrcod fprint)
                                        (if (boolean? bin-ofs)
                                            (wrcod fwrite)
                                            nop
                                        )
                                    )
                                  )
                                )
                                walls
                           )
                         )
                       )
                   )
                   (if (or (not bin-ofs) (not (boolean? bin-ofs)))
                       (beg 
                         (fprint (string-append
                                   "attribute \"element type\" string "
                                   (wq (list-ref '("lines" "quads" "cubes")
                                                  (- ndims 1)
                                       )
                                   )
                                 )
                         )
                         (fprint "attribute \"dep\" string \"connections\"")
                         (fprint "attribute \"ref\" string \"positions\"")
                         (fprint "#")
                       )
                       nop
                   )
                 )
               )
         )
        )
    (list rcod (* datsiz (expt 2 ndims)))
  )
))

(define wr-obj (lambda (grds vrs nam lam bin-ofs)
    (let* ((oid (let ((o oidn))
                  (hash-set! objids nam o)
                  (set! oidn (+ oidn 1))
                  o
                )
           )
           (posn (hash-ref objids "positions" #f))
           (conn (hash-ref objids "connections" #f))
           (dms (map (lambda (gr) (gr 'dims-full)) grds))
           (ndms (map length dms))
           (chk (if (not (= (apply min ndms) (apply max ndms)))
                    (int-err "Cannot save grids with different ranks!")
                )
           )
           (ndims (car ndms))
           (ncel (apply + (map (lambda (d) (apply * d)) dms)))
           (shp  (length vrs))
           (wrcod (lambda (prnt)
             (apply beg
                    (map (lambda (gr)
                           (gr 'forall-grid-d (reverse (iota1 ndims)) vrs
                             (lambda args
                               (apply prnt
                                      (map (lambda (v) `(real ,v))
                                           (apply lam args)
                                      )
                               )
                             )
                           )
                         )
                         grds
                    )
             )
           ))
           (rcod (beg
                   (main-p
                     (if (or (not bin-ofs) (not (boolean? bin-ofs)))
                         (fprint "object "
                                 oid
                                 " class array type float rank "
                                 (if (> (length vrs) 1) 1 0)
                                 (if (> shp 1)
                                     (string-append " shape "
                                                    (number->string shp)
                                                    " "
                                     )
                                     ""
                                 )
                                 " items"
                                 ncel
                                 (if (not (boolean? bin-ofs))
                                     "lsb ieee data"
                                     "data"
                                 )
                                 (if (not (boolean? bin-ofs))
                                     (* bin-ofs 4)
                                     " follows"
                                 )
                         )
                         nop
                     )
                   )
                   (if (not bin-ofs)
                       (wrcod fprint)
                       (if (boolean? bin-ofs)
                           (wrcod fwrite)
                           nop
                       )
                   )
                   (if (or (not bin-ofs) (not (boolean? bin-ofs)))
                       (beg
                         (main-p
                           (fprint "")
                           (fprint "attribute \"dep\" string \"positions\"")
                           (fprint "#")
                         )
                         (if (not (= oid posn))
                             (main-p
                               (fprint "object "
                                       (wq nam)
                                       " class field"
                               )
                               (fprint "component \"data\" value" oid)
                               (fprint "component \"positions\" value" posn)
                               (fprint "component \"connections\" value" conn)
                               (fprint "attribute \"name\" string " (wq nam))
                               (fprint "#")
                             )
                             nop
                         )
                       )
                   )
                 )
           )
          )
      (list rcod ncel)
  )
))

(define OpenDX:save (lambda (gr name vars)
  (set! oidn 1)
    
  (beg
    (main-p (print "Writing OpenDX file " name))
    (let* ((con (lambda (f) (wr-conn (gr 'subgrids) f)))
           (objs (lambda (f)
                   (map (lambda (vllo)
                          (let* ((vll (car vllo))
                                 (o (cadr vllo))
                                 (vn (car vll))
                                 (v (if (list? (cadr vll))
                                        (cadr vll)
                                        (list (cadr vll))
                                    )
                                 )
                                 (lam (caddr vll))
                                )
                            (wr-obj (gr 'subgrids) v vn lam o)
                          )
                        )
                        (if (boolean? f)
                            (map (lambda (v) (list v f)) vars)
                            (zip vars f)
                        )
                   )
                 )
           )
           (con1 (con #t))
           (objs1 (objs #t))
           
           (con2 (con 0))
           (lens (cons (cadr con1)
                       (map cadr objs1)
                 )
           )
           (ofss (letrec ((sm (lambda (l o)
                                (if (null? l)
                                    (list)
                                    (let ((o1 (+ o (car l))))
                                      (cons o1 (sm (cdr l) o1))
                                    )
                                )
                              )
                          )
                         )
                   (reverse (cdr (reverse (sm lens 0))))
                 )
           )
           (dbg (format #t "LENS: ~a\nOFS: ~a\n" lens ofss))
           (objs2 (objs ofss))
          )
       (beg
         (to-file (string-append name "_tmp") 'replace 'main
           (beg
             (main-p
               (car con2)
               (apply beg (map car objs2))
               (fprint "object \"default\" class group")
               (apply beg
                 (map (lambda (vl)
                        (if (string=? (car vl) "positions")
                            nop
                            (fprint (string-append "member \""
                                                   (car vl) 
                                                   "\" value \""
                                                   (car vl)
                                                   "\""
                                    )
                            )
                        )
                      )
                      vars
                 )
               )
               (fprint "attribute \"name\" string \"default\"")
               (fprint "#")
               (fprint "end")
             )
           )
         )
         (to-file (string-append name "_tmp") 'append 'bin 'main
             (car con1)
             (apply beg (map car objs1))
         )
         (main-p (call "rename" (string-append  name "_tmp ") name))
       )
    )
  )
))

)
